home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlobj.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  12KB  |  474 lines
  1. /* xlobj - xlisp object functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xlvalue;
  10. extern LVAL s_stdout,s_lambda;
  11.  
  12. /* local variables */
  13. static LVAL s_self,k_new,k_isnew;
  14. static LVAL class,object;
  15.  
  16. /* instance variable numbers for the class 'Class' */
  17. #define MESSAGES    0    /* list of messages */
  18. #define IVARS        1    /* list of instance variable names */
  19. #define CVARS        2    /* list of class variable names */
  20. #define CVALS        3    /* list of class variable values */
  21. #define SUPERCLASS    4    /* pointer to the superclass */
  22. #define IVARCNT        5    /* number of class instance variables */
  23. #define IVARTOTAL    6    /* total number of instance variables */
  24.  
  25. /* number of instance variables for the class 'Class' */
  26. #define CLASSSIZE    7
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL entermsg();
  30. FORWARD LVAL sendmsg();
  31. FORWARD LVAL evmethod();
  32.  
  33. /* xsend - send a message to an object */
  34. LVAL xsend()
  35. {
  36.     LVAL obj;
  37.     obj = xlgaobject();
  38.     return (sendmsg(obj,getclass(obj),xlgasymbol()));
  39. }
  40.  
  41. /* xsendsuper - send a message to the superclass of an object */
  42. LVAL xsendsuper()
  43. {
  44.     LVAL env,p;
  45.     for (env = xlenv; env; env = cdr(env))
  46.     if ((p = car(env)) && objectp(car(p)))
  47.         return (sendmsg(car(p),
  48.                 getivar(cdr(p),SUPERCLASS),
  49.                 xlgasymbol()));
  50.     xlfail("not in a method");
  51. }
  52.  
  53. /* xlclass - define a class */
  54. LVAL xlclass(name,vcnt)
  55.   char *name; int vcnt;
  56. {
  57.     LVAL sym,cls;
  58.  
  59.     /* create the class */
  60.     sym = xlenter(name);
  61.     cls = newobject(class,CLASSSIZE);
  62.     setvalue(sym,cls);
  63.  
  64.     /* set the instance variable counts */
  65.     setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
  66.     setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
  67.  
  68.     /* set the superclass to 'Object' */
  69.     setivar(cls,SUPERCLASS,object);
  70.  
  71.     /* return the new class */
  72.     return (cls);
  73. }
  74.  
  75. /* xladdivar - enter an instance variable */
  76. xladdivar(cls,var)
  77.   LVAL cls; char *var;
  78. {
  79.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  80. }
  81.  
  82. /* xladdmsg - add a message to a class */
  83. xladdmsg(cls,msg,offset)
  84.   LVAL cls; char *msg; int offset;
  85. {
  86.     extern FUNDEF funtab[];
  87.     LVAL mptr;
  88.  
  89.     /* enter the message selector */
  90.     mptr = entermsg(cls,xlenter(msg));
  91.  
  92.     /* store the method for this message */
  93.     rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
  94. }
  95.  
  96. /* xlobgetvalue - get the value of an instance variable */
  97. int xlobgetvalue(pair,sym,pval)
  98.   LVAL pair,sym,*pval;
  99. {
  100.     LVAL cls,names;
  101.     int ivtotal,n;
  102.  
  103.     /* find the instance or class variable */
  104.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  105.  
  106.     /* check the instance variables */
  107.     names = getivar(cls,IVARS);
  108.     ivtotal = getivcnt(cls,IVARTOTAL);
  109.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  110.         if (car(names) == sym) {
  111.         *pval = getivar(car(pair),n);
  112.         return (TRUE);
  113.         }
  114.         names = cdr(names);
  115.     }
  116.  
  117.     /* check the class variables */
  118.     names = getivar(cls,CVARS);
  119.     for (n = 0; consp(names); ++n) {
  120.         if (car(names) == sym) {
  121.         *pval = getelement(getivar(cls,CVALS),n);
  122.         return (TRUE);
  123.         }
  124.         names = cdr(names);
  125.     }
  126.     }
  127.  
  128.     /* variable not found */
  129.     return (FALSE);
  130. }
  131.  
  132. /* xlobsetvalue - set the value of an instance variable */
  133. int xlobsetvalue(pair,sym,val)
  134.   LVAL pair,sym,val;
  135. {
  136.     LVAL cls,names;
  137.     int ivtotal,n;
  138.  
  139.     /* find the instance or class variable */
  140.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  141.  
  142.     /* check the instance variables */
  143.     names = getivar(cls,IVARS);
  144.     ivtotal = getivcnt(cls,IVARTOTAL);
  145.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  146.         if (car(names) == sym) {
  147.         setivar(car(pair),n,val);
  148.         return (TRUE);
  149.         }
  150.         names = cdr(names);
  151.     }
  152.  
  153.     /* check the class variables */
  154.     names = getivar(cls,CVARS);
  155.     for (n = 0; consp(names); ++n) {
  156.         if (car(names) == sym) {
  157.         setelement(getivar(cls,CVALS),n,val);
  158.         return (TRUE);
  159.         }
  160.         names = cdr(names);
  161.     }
  162.     }
  163.  
  164.     /* variable not found */
  165.     return (FALSE);
  166. }
  167.  
  168. /* obisnew - default 'isnew' method */
  169. LVAL obisnew()
  170. {
  171.     LVAL self;
  172.     self = xlgaobject();
  173.     xllastarg();
  174.     return (self);
  175. }
  176.  
  177. /* obclass - get the class of an object */
  178. LVAL obclass()
  179. {
  180.     LVAL self;
  181.     self = xlgaobject();
  182.     xllastarg();
  183.     return (getclass(self));
  184. }
  185.  
  186. /* obshow - show the instance variables of an object */
  187. LVAL obshow()
  188. {
  189.     LVAL self,fptr,cls,names;
  190.     int ivtotal,n;
  191.  
  192.     /* get self and the file pointer */
  193.     self = xlgaobject();
  194.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  195.     xllastarg();
  196.  
  197.     /* get the object's class */
  198.     cls = getclass(self);
  199.  
  200.     /* print the object and class */
  201.     xlputstr(fptr,"Object is ");
  202.     xlprint(fptr,self,TRUE);
  203.     xlputstr(fptr,", Class is ");
  204.     xlprint(fptr,cls,TRUE);
  205.     xlterpri(fptr);
  206.  
  207.     /* print the object's instance variables */
  208.     for (; cls; cls = getivar(cls,SUPERCLASS)) {
  209.     names = getivar(cls,IVARS);
  210.     ivtotal = getivcnt(cls,IVARTOTAL);
  211.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  212.         xlputstr(fptr,"  ");
  213.         xlprint(fptr,car(names),TRUE);
  214.         xlputstr(fptr," = ");
  215.         xlprint(fptr,getivar(self,n),TRUE);
  216.         xlterpri(fptr);
  217.         names = cdr(names);
  218.     }
  219.     }
  220.  
  221.     /* return the object */
  222.     return (self);
  223. }
  224.  
  225. /* clnew - create a new object instance */
  226. LVAL clnew()
  227. {
  228.     LVAL self;
  229.     self = xlgaobject();
  230.     return (newobject(self,getivcnt(self,IVARTOTAL)));
  231. }
  232.  
  233. /* clisnew - initialize a new class */
  234. LVAL clisnew()
  235. {
  236.     LVAL self,ivars,cvars,super;
  237.     int n;
  238.  
  239.     /* get self, the ivars, cvars and superclass */
  240.     self = xlgaobject();
  241.     ivars = xlgalist();
  242.     cvars = (moreargs() ? xlgalist() : NIL);
  243.     super = (moreargs() ? xlgaobject() : object);
  244.     xllastarg();
  245.  
  246.     /* store the instance and class variable lists and the superclass */
  247.     setivar(self,IVARS,ivars);
  248.     setivar(self,CVARS,cvars);
  249.     setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
  250.     setivar(self,SUPERCLASS,super);
  251.  
  252.     /* compute the instance variable count */
  253.     n = listlength(ivars);
  254.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  255.     n += getivcnt(super,IVARTOTAL);
  256.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  257.  
  258.     /* return the new class object */
  259.     return (self);
  260. }
  261.  
  262. /* clanswer - define a method for answering a message */
  263. LVAL clanswer()
  264. {
  265.     LVAL self,msg,fargs,code,mptr;
  266.  
  267.     /* message symbol, formal argument list and code */
  268.     self = xlgaobject();
  269.     msg = xlgasymbol();
  270.     fargs = xlgalist();
  271.     code = xlgalist();
  272.     xllastarg();
  273.  
  274.     /* make a new message list entry */
  275.     mptr = entermsg(self,msg);
  276.  
  277.     /* setup the message node */
  278.     xlprot1(fargs);
  279.     fargs = cons(s_self,fargs); /* add 'self' as the first argument */
  280.     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
  281.     xlpop();
  282.  
  283.     /* return the object */
  284.     return (self);
  285. }
  286.  
  287. /* entermsg - add a message to a class */
  288. LOCAL LVAL entermsg(cls,msg)
  289.   LVAL cls,msg;
  290. {
  291.     LVAL lptr,mptr;
  292.  
  293.     /* lookup the message */
  294.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  295.     if (car(mptr = car(lptr)) == msg)
  296.         return (mptr);
  297.  
  298.     /* allocate a new message entry if one wasn't found */
  299.     xlsave1(mptr);
  300.     mptr = consa(msg);
  301.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  302.     xlpop();
  303.  
  304.     /* return the symbol node */
  305.     return (mptr);
  306. }
  307.  
  308. /* sendmsg - send a message to an object */
  309. LOCAL LVAL sendmsg(obj,cls,sym)
  310.   LVAL obj,cls,sym;
  311. {
  312.     LVAL msg,msgcls,method,val,p;
  313.  
  314.     /* look for the message in the class or superclasses */
  315.     for (msgcls = cls; msgcls; ) {
  316.  
  317.     /* lookup the message in this class */
  318.     for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
  319.         if ((msg = car(p)) && car(msg) == sym)
  320.         goto send_message;
  321.  
  322.     /* look in class's superclass */
  323.     msgcls = getivar(msgcls,SUPERCLASS);
  324.     }
  325.  
  326.     /* message not found */
  327.     xlerror("no method for this message",sym);
  328.  
  329. send_message:
  330.  
  331.     /* insert the value for 'self' (overwrites message selector) */
  332.     *--xlargv = obj;
  333.     ++xlargc;
  334.     
  335.     /* invoke the method */
  336.     if ((method = cdr(msg)) == NULL)
  337.     xlerror("bad method",method);
  338.     switch (ntype(method))